home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / tzfile.scm < prev    next >
Text File  |  1999-04-19  |  5KB  |  139 lines
  1. ; "tzfile.scm", Read sysV style (binary) timezone file.
  2. ; Copyright (c) 1997 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'byte)
  21.  
  22. (define (tzfile:read-long port)
  23.   (let ((hibyte (read-byte port)))
  24.     (do ((idx 3 (+ -1 idx))
  25.      (val (if (> hibyte 127) (+ #x-100 hibyte) hibyte)
  26.           (+ (ash val 8) (read-byte port))))
  27.     ((zero? idx) val))))
  28. (define (tzfile:read-longs len port)
  29.   (define ra (make-vector len 0))
  30.   (do ((idx 0 (+ 1 idx)))
  31.       ((>= idx len) ra)
  32.     (vector-set! ra idx (tzfile:read-long port))))
  33.  
  34. (define (tzfile:read-bool port)
  35.   (let ((c (read-char port)))
  36.     (if (eof-object? c) c (if (zero? (char->integer c)) #f #t))))
  37.  
  38. (define (tzfile:read path)
  39.   (define null (integer->char 0))
  40.   (call-with-input-file path
  41.     (lambda (port)
  42.       (do ((idx 0 (+ 1 idx)))        ;reserved.
  43.       ((>= idx 20))
  44.     (read-char port))
  45.       (let* ((ttisgmtcnt (tzfile:read-long port))
  46.          (ttisstdcnt (tzfile:read-long port))
  47.          (leapcnt (tzfile:read-long port))
  48.          (timecnt (tzfile:read-long port))
  49.          (typecnt (tzfile:read-long port))
  50.          (charcnt (tzfile:read-long port))
  51.          (transition-times (tzfile:read-longs timecnt port))
  52.          (transition-types
  53.           (do ((ra (make-vector timecnt 0))
  54.            (idx 0 (+ 1 idx)))
  55.           ((>= idx timecnt) ra)
  56.         (vector-set! ra idx (read-byte port))))
  57.          ;;(printf "  typecnt = %d\n" typecnt)
  58.          (mode-table (do ((tt (make-vector typecnt #f))
  59.                   (idx 0 (+ 1 idx)))
  60.                  ((>= idx typecnt) tt)
  61.                (let* ((gmt-offset (tzfile:read-long port))
  62.                   (isdst (tzfile:read-bool port))
  63.                   (abbrev-index (read-byte port)))
  64.                  (vector-set! tt idx
  65.                       (vector abbrev-index gmt-offset
  66.                           isdst #f #f)))))
  67.          ;;(printf "  %d bytes of abbreviations:\n" charcnt)
  68.          (abbrevs (do ((ra (make-bytes charcnt 0))
  69.                (idx 0 (+ 1 idx)))
  70.               ((>= idx charcnt) ra)
  71.             (string-set! ra idx (read-char port))))
  72.          (leap-seconds (tzfile:read-longs (* 2 leapcnt) port)))
  73.     (cond ((not (or (eqv? 0 ttisstdcnt) (eqv? typecnt ttisstdcnt)))
  74.            (slib:warn 'tzfile:read "format error" ttisstdcnt typecnt)))
  75.     (cond ((not (or (eqv? 0 ttisgmtcnt) (eqv? typecnt ttisgmtcnt)))
  76.            (slib:warn 'tzfile:read "format error" ttisgmtcnt typecnt)))
  77.     ;;(printf " reading %d transition attributes\n" ttisstdcnt)
  78.     (do ((idx 0 (+ 1 idx)))
  79.         ((>= idx ttisstdcnt))
  80.       (vector-set! (vector-ref mode-table idx) 3 (tzfile:read-bool port)))
  81.     ;;(printf " reading %d transition attributes\n" ttisgmtcnt)
  82.     (do ((idx 0 (+ 1 idx)))
  83.         ((>= idx ttisgmtcnt))
  84.       (vector-set! (vector-ref mode-table idx) 4 (tzfile:read-bool port)))
  85.     (cond ((not (eof-object? (peek-char port)))
  86.            (slib:warn 'tzfile:read "bytes left at end")))
  87.     (do ((idx 0 (+ 1 idx)))
  88.         ((>= idx ttisstdcnt))
  89.       (let ((rec (vector-ref mode-table idx)))
  90.         (vector-set!
  91.          rec 0 (let loop ((pos (vector-ref rec 0)))
  92.              (cond ((>= pos (string-length abbrevs))
  93.                 (slib:warn 'tzfile:read "format error" abbrevs) #f)
  94.                ((char=? null (string-ref abbrevs pos))
  95.                 (substring abbrevs (vector-ref rec 0) pos))
  96.                (else (loop (+ 1 pos))))))))
  97.     (list path mode-table leap-seconds transition-times transition-types)
  98.     ))))
  99.  
  100. (define (tzfile:transition-index time zone)
  101.   (and zone
  102.        (apply
  103.     (lambda (path mode-table leap-seconds transition-times transition-types)
  104.       (let ((ntrns (vector-length transition-times)))
  105.         (if (zero? ntrns) -1
  106.         (let loop ((lidx (ash (+ 1 ntrns) -1))
  107.                (jmp (ash (+ 1 ntrns) -2)))
  108.           (let* ((idx (max 0 (min lidx (+ -1 ntrns))))
  109.              (idx-time (vector-ref transition-times idx)))
  110.             (cond ((<= jmp 0)
  111.                (+ idx (if (>= time idx-time) 0 -1)))
  112.               ((= time idx-time) idx)
  113.               ((and (zero? idx) (< time idx-time)) -1)
  114.               ((and (not (= idx lidx)) (not (< time idx-time))) idx)
  115.               (else
  116.                (loop ((if (< time idx-time) - +) idx jmp)
  117.                  (if (= 1 jmp) 0 (ash (+ 1 jmp) -1))))))))))
  118.     (cdr (vector->list zone)))))
  119.  
  120. (define (tzfile:get-std-spec mode-table)
  121.   (do ((type-idx 0 (+ 1 type-idx)))
  122.       ((or (>= type-idx (vector-length mode-table))
  123.        (not (vector-ref (vector-ref mode-table type-idx) 2)))
  124.        (if (>= type-idx (vector-length mode-table))
  125.        (vector-ref mode-table 0)
  126.        (vector-ref mode-table type-idx)))))
  127.  
  128. (define (tzfile:get-zone-spec time zone)
  129.   (apply
  130.    (lambda (path mode-table leap-seconds transition-times transition-types)
  131.      (let* ((trans-idx (tzfile:transition-index time zone)))
  132.        (if (zero? (vector-length transition-types))
  133.        (vector-ref mode-table 0)
  134.        (if (negative? trans-idx)
  135.            (tzfile:get-std-spec mode-table)
  136.            (vector-ref mode-table 
  137.                (vector-ref transition-types trans-idx))))))
  138.    (cdr (vector->list zone))))
  139.